home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / LISP / BASIC.LSP next >
Encoding:
Text File  |  1993-10-25  |  24.4 KB  |  757 lines
  1. ;; PC Scheme Common Lisp Compatibility Package
  2. ;;
  3. ;; (c) Copyright 1990 Carl W. Hoffman.  All rights reserved.
  4. ;;
  5. ;; This file may be freely copied, distributed, or modified for non-commercial
  6. ;; use provided that this copyright notice is not removed.  For further
  7. ;; information about other utilities for Common Lisp or Scheme, contact the
  8. ;; following address:
  9. ;;
  10. ;;   Carl W. Hoffman, 363 Marlborough Street, Boston, MA 02115, U.S.A.
  11. ;;   Internet: CWH@AI.MIT.EDU    CompuServe: 76416,3365    Fax: 617-262-4284
  12.  
  13. ;; This package has been tested with PC Scheme version 3.02.
  14.  
  15. ;; To do:
  16. ;;   Place all of these bindings in a separate environment so
  17. ;;     as not to break Scheme programs.  The property lists
  18. ;;     will still be broken, however.
  19. ;;   N-ary =, /=, <, >, <=, >=, CHAR=, CHAR/=, CHAR<, CHAR>, CHAR<=, CHAR>=
  20. ;;   Translate T into ELSE inside of COND.
  21. ;;   Implement DO*, PROG*
  22. ;;   Create DEFUN-CL, DEFMACRO-CL, and DEFUN-INLINE-CL for creating
  23. ;;     user-visible CL functions and macros.  This should create an arglist,
  24. ;;     like DEFUN.  Hide internal functions in a CL-INTERNALS environment
  25. ;;     which isn't user-visible.
  26. ;;   Implement ECASE correctly.
  27.  
  28. ;; R^3RS functions missing from PC Scheme.  See also the file R3RS.SCM.
  29.  
  30. ;************************************************************************
  31. ; added by LB, because suppressed in PCS.
  32. (define-integrable nil '())
  33. (define-integrable t #T)
  34. ;************************************************************************
  35.  
  36. (define (char-upper-case? char)
  37.   (and (char<=? #\A char) (char<=? char #\Z)))
  38.  
  39. (define (char-lower-case? char)
  40.   (and (char<=? #\a char) (char<=? char #\z)))
  41.  
  42. (define (char-alphabetic? char)
  43.   (or (char-upper-case? char)
  44.       (char-lower-case? char)))
  45.  
  46. (define (char-numeric? char)
  47.   (and (char<=? #\0 char) (char<=? char #\9)))
  48.  
  49. (define (char-whitespace? char)
  50.   (or (char=? char #\space)
  51.       (char=? char #\tab)
  52.       (char=? char #\newline)))
  53.  
  54. ;; Use DEFINE-INTEGRABLE rather than ALIAS, SYNTAX, or MACRO when defining
  55. ;; function synonyms.  If ALIAS, SYNTAX, or MACRO is used, then it is not
  56. ;; possible to later use that name as a local variable.
  57.  
  58. (define-integrable null null?)
  59. (define-integrable atom atom?)
  60. (define-integrable consp pair?)
  61. (define-integrable symbolp symbol?)
  62. (define-integrable simple-string-p string?)
  63. (define-integrable simple-vector-p vector?)
  64. (define-integrable stringp string?)
  65. (define-integrable vectorp vector?)
  66. (define-integrable numberp number?)
  67. (define-integrable integerp integer?)
  68. (define-integrable rationalp rational?)
  69. (define-integrable floatp float?)
  70. (define-integrable characterp char?)
  71.  
  72. (defun-inline listp (x)
  73.   (or (null x) (pair? x)))
  74.  
  75. (defun-clcp %%endp-error (x)
  76.   (error "The argument to ENDP, ~S, was not a list." x))
  77.  
  78. (defun-inline endp (x)
  79.   (or (null x)
  80.       (and (not (pair? x))
  81.            (%%endp-error x))))
  82.  
  83. (define-integrable eq eq?)
  84. (define-integrable eql eqv?)
  85. (define-integrable equal equal?)
  86.  
  87. (define-integrable zerop zero?)
  88. (define-integrable plusp positive?)
  89. (define-integrable minusp negative?)
  90. (define-integrable oddp odd?)
  91. (define-integrable evenp even?)
  92.  
  93. (defun-inline /= (n1 n2)
  94.   (not (= n1 n2)))
  95.  
  96. (define-integrable char=  char=?)
  97. (define-integrable char<  char<?)
  98. (define-integrable char>  char>?)
  99. (define-integrable char<= char<=?)
  100. (define-integrable char>= char>=?)
  101.  
  102. (defun-inline char/= (c1 c2)
  103.   (not (char= c1 c2)))
  104.  
  105. (define-integrable char-equal        char-ci=?)
  106. (define-integrable char-lessp        char-ci<?)
  107. (define-integrable char-greaterp     char-ci>?)
  108. (define-integrable char-not-lessp    char-ci>=?)
  109. (define-integrable char-not-greaterp char-ci<=?)
  110.  
  111. ;; The following functions are all integrable.  The translator should have a
  112. ;; flag to enable integration and disable type checking.
  113.  
  114. (defun-inline char-not-equal (c1 c2)
  115.   (not (char-equal c1 c2)))
  116.  
  117. (defun standard-char-p (char)
  118.   (check-type char character)
  119.   t)
  120.  
  121. (defun graphic-char-p (char)
  122.   (check-type char character)
  123.   (not (or (char= char #\newline)
  124.            (char= char #\tab)
  125.            (char= char #\page))))
  126.  
  127. (defun string-char-p (char)
  128.   (check-type char character)
  129.   t)
  130.  
  131. (defun alpha-char-p (char)
  132.   (check-type char character)
  133.   (char-alphabetic? char))
  134.  
  135. (defun upper-case-p (char)
  136.   (check-type char character)
  137.   (char-upper-case? char))
  138.  
  139. (defun lower-case-p (char)
  140.   (check-type char character)
  141.   (char-lower-case? char))
  142.  
  143. (defun both-case-p (char)
  144.   (check-type char character)
  145.   (char-alphabetic? char))
  146.  
  147. (defun digit-char-p (char)
  148.   (check-type char character)
  149.   (and (char-numeric? char)
  150.        (- (char-code char) (char-code #\0))))
  151.  
  152. (defun alphanumericp (char)
  153.   (check-type char character)
  154.   (or (char-alphabetic? char) (char-numeric? char)))
  155.  
  156. (define-integrable last last-pair)
  157.  
  158. (define-integrable 1- -1+)
  159.  
  160. (define-integrable intern string->symbol)
  161. (define-integrable get getprop)
  162.  
  163. (define-integrable symbol-name symbol->string)
  164. (define-integrable symbol-plist proplist)
  165.  
  166. (defmacro defvar (name &optional (initial-value nil iv?) documentation)
  167.   (when (and documentation (not (stringp documentation)))
  168.     (error "The third argument to DEFVAR was ~S, which is not a ~
  169.             documentation string."
  170.            documentation))
  171.   `(begin
  172.      (if (eq #!unassigned (access ,name (the-environment)))
  173.          (define ,name . ,(if iv? `(,initial-value) '())))
  174.      ',name))
  175.  
  176. (defmacro defparameter (name initial-value &optional documentation)
  177.   (when (and documentation (not (stringp documentation)))
  178.     (error "The third argument to DEFPARAMETER was ~S, which is not a ~
  179.             documentation string."
  180.            documentation))
  181.   `(begin
  182.      (define ,name ,initial-value)
  183.      ',name))
  184.  
  185. (defmacro defconstant (name initial-value &optional documentation)
  186.   (when (and documentation (not (stringp documentation)))
  187.     (error "The third argument to DEFPARAMETER was ~S, which is not a ~
  188.             documentation string."
  189.            documentation))
  190.   `(begin
  191.      (define-integrable ,name ,initial-value)
  192.      ',name))
  193.  
  194. (alias prog1 begin0)
  195. (alias progn begin)
  196.  
  197. (defmacro prog2 (first second &rest rest)
  198.   `(begin ,first ,(if rest `(begin0 ,second . ,rest) second)))
  199.  
  200. (syntax (declare . declarations) 'declare)
  201. (syntax (proclaim . declarations) 'proclaim)
  202.  
  203. (syntax (when condition . body)
  204.         (cond (condition . body)))
  205.  
  206. (syntax (unless condition . body)
  207.         (cond ((not condition) . body)))
  208.  
  209. (defmacro values (&rest args)
  210.   (if (null args)
  211.       '*the-non-printing-object*
  212.       (car args)))
  213.  
  214. ;; This should use CHECK-ARG-TYPE or whatever the CL thing is.
  215.  
  216. (defun-clcp macro-function (symbol &optional (error? t))
  217.   (if (symbolp symbol)
  218.       (get symbol 'pcs*macro)
  219.       (if error?
  220.           (error "The first argument to MACRO-FUNCTION, ~S, was not a symbol."
  221.                  symbol))))
  222.  
  223. (defun-clcp primop-handler (symbol &optional (error? t))
  224.   (if (symbolp symbol)
  225.       (get symbol 'pcs*primop-handler)
  226.       (if error?
  227.           (error "The first argument to PRIMOP-HANDLER, ~S, was not a symbol."
  228.                  symbol))))
  229.  
  230. (defun-clcp rename-macro (old new)
  231.   (putprop new (get old 'pcs*macro) 'pcs*macro)
  232.   (remprop old 'pcs*macro))
  233.  
  234. (defun-clcp rename-primop (old new)
  235.   (when (get old 'pcs*primop-handler)
  236.     (putprop new (get old 'pcs*primop-handler) 'pcs*primop-handler)
  237.     (remprop old 'pcs*primop-handler))
  238.   (when (get old 'pcs*opcode)
  239.     (putprop new (get old 'pcs*opcode) 'pcs*opcode)
  240.     (remprop old 'pcs*opcode)))
  241.  
  242. (define (copy-primop from to)
  243.   (setf (primop-handler to) (primop-handler from)))
  244.  
  245. ;; Use EVAL to suppress the effect of the alias.
  246. ;; (Actually, we no longer alias FLOOR, but keep it this way anyway.)
  247.  
  248. (unless (getprop 'scheme-case 'pcs*macro)
  249.  
  250.   (rename-macro 'let         'scheme-let)
  251.   (rename-macro 'let*        'scheme-let*)
  252.   ;(rename-macro  'cond       'scheme-cond)
  253.   (rename-macro 'case        'scheme-case)
  254.   (rename-macro 'do          'scheme-do)
  255.   (rename-macro 'error       'scheme-error)
  256.  
  257.   (define scheme-floor         (eval 'floor))
  258.   (define scheme-ceiling       (eval 'ceiling))
  259.   (define scheme-truncate      (eval 'truncate))
  260.   (define scheme-round         (eval 'round))
  261.   (define scheme-member        (eval 'member))
  262.   (define scheme-fresh-line    (eval 'fresh-line))
  263.   (define scheme-read          (eval 'read))
  264.   (define scheme-write         (eval 'write))
  265.  
  266.   (define scheme-apply         (eval 'apply))
  267.   (define scheme-assoc         (eval 'assoc))
  268.   (define scheme-length        (eval 'length))
  269.   (define scheme-read-char     (eval 'read-char))
  270.   (define scheme-write-char    (eval 'write-char))
  271.   (define scheme-make-string   (eval 'make-string))
  272.  
  273.   (rename-primop 'apply        'scheme-apply)
  274.   (rename-primop 'assoc        'scheme-assoc)
  275.   (rename-primop 'length       'scheme-length)
  276.   (rename-primop 'read-char    'scheme-read-char)
  277.   (rename-primop 'write-char   'scheme-write-char)
  278.   (rename-primop 'make-string  'scheme-make-string)
  279.   )
  280.  
  281. (defun-clcp %%transform-let-bindings (bindings)
  282.   (mapcar (lambda (binding)
  283.             (cond ((symbolp binding)
  284.                    (list binding 'nil))
  285.                   ((and (consp binding) (null (cdr binding)))
  286.                    (list (car binding) 'nil))
  287.                   (else
  288.                     binding)))
  289.        bindings))
  290.  
  291. (defmacro let (bindings &body body)
  292.   `(scheme-let ,(%%transform-let-bindings bindings) . ,body))
  293.  
  294. (defmacro let* (bindings &body body)
  295.   `(scheme-let* ,(%%transform-let-bindings bindings) . ,body))
  296.  
  297. ;; Change this so that if there is no ELSE clause, add (ELSE NIL).
  298.  
  299. ; (defmacro cond (&body clauses)
  300. ;   (let ((result ()))
  301. ;     (do ((l clauses (cdr l)))
  302. ;         ((null l))
  303. ;       (let ((clause (car l)))
  304. ;         (cond ((memq (car clause) '(t otherwise))
  305. ;                (unless (null (cdr l))
  306. ;                  (error "T or OTHERWISE must be final COND clause"))
  307. ;                (push `(else . ,(cdr clause)) result))
  308. ;               (else
  309. ;                 (push clause result)))))
  310. ;     `(scheme-cond . ,(nreverse result))))
  311.  
  312. ;; Change this so that if there is no ELSE clause, we add (ELSE NIL).
  313.  
  314. (defmacro case (key &body clauses)
  315.   `(scheme-case ,key .
  316.     ,(let ((final-clause-key nil))
  317.        (map (lambda (clause)
  318.               (when final-clause-key
  319.                 (error "A ~A clause in a CASE statement is followed by ~
  320.                         the clause ~S"
  321.                        final-clause-key clause))
  322.               (cond ((memq (car clause) '(t otherwise))
  323.                      (setq final-clause-key (car clause))
  324.                      `(else . ,(cdr clause)))
  325.                     ((null (cdr clause))
  326.                      `(,(car clause) nil))
  327.                     (else
  328.                       clause)))
  329.             clauses))))
  330.  
  331. (define-integrable ecase case)
  332.  
  333. ;; Treat NIL as a special case to minimize consing.
  334.  
  335. (defun make-return-from (name)
  336.   (if (eq name 'nil)
  337.       'return-from-nil
  338.       (symbol-append 'return-from- name)))
  339.  
  340. (defmacro return-from (name &optional value)
  341.   (unless (symbolp name)
  342.     (error "The first argument to RETURN-FROM, ~S, was not a symbol." name))
  343.   `(,(make-return-from name) ,value))
  344.  
  345. (defmacro return (&optional value)
  346.   `(,(make-return-from 'nil) ,value))
  347.  
  348. ;; This should MAPFORMS over the body.  If RETURN-FROM does not appear within
  349. ;; the lexical contour defined by the BLOCK, then don't generate CALL/CC.
  350.  
  351. (defmacro block (name &body body)
  352.   (unless (symbolp name)
  353.     (error "The first argument to BLOCK, ~S, was not a symbol." name))
  354.   `(call/cc (lambda (,(make-return-from name)) . ,body)))
  355.  
  356. (defmacro do (vars test &body body)
  357.   (unless (cdr test)
  358.     (setq test (list (car test) 'nil)))
  359.   `(block nil (scheme-do ,vars ,test . ,body)))
  360.  
  361. (defmacro loop (&body body)
  362.   `(block nil (scheme-do () (nil) . ,body)))
  363.  
  364. (defmacro prog (bindings &body body)
  365.   `(block nil (let ,bindings . ,body)))
  366.  
  367. ;; Allow the first argument to be a symbol as well as a function.
  368. ;; Accept additional arguments before the final list argument, i.e.
  369. ;; ZetaLisp LEXPR-FUNCALL.
  370.  
  371. (define (apply fcn . args)
  372.   (cond ((procedure? fcn))
  373.         ((symbolp fcn)
  374.          (setq fcn (eval fcn)))
  375.         (else
  376.          (error "The first argument to APPLY, ~S, ~
  377.                  is not a procedure or symbol."
  378.                 fcn)))
  379.   ;; I'm not sure this is always safe to do.
  380.   ;; We may be clobbering some constant list structure someplace.
  381.   (if (null (cdr args))
  382.       (scheme-apply fcn (car args))
  383.       (progn
  384.         (do ((l args (cdr l)))
  385.             ((null (cddr l))
  386.              (setf (cdr l) (cadr l))))
  387.         (scheme-apply fcn args))))
  388.  
  389. (defun binary-floor (numerator &optional denominator)
  390.   (if denominator
  391.       ;; Yes, I know there are more efficient ways of doing this.
  392.       (scheme-floor (/ numerator denominator))
  393.       (scheme-floor numerator)))
  394.  
  395. (defun binary-ceiling (numerator &optional denominator)
  396.   (if denominator
  397.       ;; Yes, I know there are more efficient ways of doing this.
  398.       (scheme-ceiling (/ numerator denominator))
  399.       (scheme-ceiling numerator)))
  400.  
  401. (defun binary-truncate (numerator &optional denominator)
  402.   (if denominator
  403.       ;; Yes, I know there are more efficient ways of doing this.
  404.       (scheme-truncate (/ numerator denominator))
  405.       (scheme-truncate numerator)))
  406.  
  407. (defun binary-round (numerator &optional denominator)
  408.   (if denominator
  409.       ;; Yes, I know there are more efficient ways of doing this.
  410.       (scheme-round (/ numerator denominator))
  411.       (scheme-round numerator)))
  412.  
  413. ;; FLOOR, CEILING, TRUNCATE, and ROUND are integrable.
  414. ;; Therefore, it is necessary to use DEFINE-INTEGRABLE rather than DEFINE so
  415. ;; that the original definitions are not integrated into the code.
  416.  
  417. (define-integrable floor binary-floor)
  418. (define-integrable ceiling binary-ceiling)
  419. (define-integrable truncate binary-truncate)
  420. (define-integrable round binary-round)
  421.  
  422. (define-integrable rplaca set-car!)
  423. (define-integrable rplacd set-cdr!)
  424.  
  425. ;; REVERSE! is not defined in the R^3 standard.
  426.  
  427. (define-integrable nreverse reverse!)
  428.  
  429. (define-integrable rest   cdr)
  430. (define-integrable first  car)
  431. (define-integrable second cadr)
  432. (define-integrable third  caddr)
  433. (define-integrable fourth cadddr)
  434.  
  435. (defun-inline fifth   (x) (car    (cddddr x)))
  436. (defun-inline sixth   (x) (cadr   (cddddr x)))
  437. (defun-inline seventh (x) (caddr  (cddddr x)))
  438. (defun-inline eighth  (x) (cadddr (cddddr x)))
  439. (defun-inline ninth   (x) (car    (cddddr (cddddr x))))
  440. (defun-inline tenth   (x) (cadr   (cddddr (cddddr x))))
  441.  
  442. (define-integrable char-code char->integer)
  443. (define-integrable code-char integer->char)
  444.  
  445. (define-integrable char  string-ref)
  446. (define-integrable schar string-ref)
  447. (define-integrable svref vector-ref)
  448.  
  449. ;; Arrays
  450.  
  451. (defun arrayp (x)
  452.   (or (stringp x) (vectorp x)))
  453.  
  454. (defun aref (array subscript)
  455.   (cond ((stringp array)
  456.          (string-ref array subscript))
  457.         ((vectorp array)
  458.          (vector-ref array subscript))
  459.         (else
  460.          (error "The first argument to AREF, ~S, is not an array."
  461.                 array))))
  462.  
  463. (defun-clcp %%setf-aref (value array subscript)
  464.   (cond ((stringp array)
  465.          (string-set! array subscript value))
  466.         ((vectorp array)
  467.          (vector-set! array subscript value))
  468.         (else
  469.          (error "The second argument to SETF-AREF, ~S, is not an array."
  470.                 array)))
  471.   value)
  472.  
  473. (define-integrable make-array make-vector)
  474.  
  475. ;; Strings (p. 300-302)
  476.  
  477. (defun string (x)
  478.   (cond ((stringp x)
  479.          x)
  480.         ((symbolp x)
  481.          (symbol-name x))
  482.         ((characterp x)
  483.          (make-string 1 :initial-element x))
  484.         (else
  485.          (error "The argument, ~S, cannot be coerced to a string." x))))
  486.  
  487. ;; The following functions can be compiled inline if the arguments are
  488. ;; declared to be simple strings.
  489.  
  490. (defun string= (string1 string2)
  491.   (string=? (string string1) (string string2)))
  492.  
  493. (defun string-equal (string1 string2)
  494.   (string-ci=? (string string1) (string string2)))
  495.  
  496. (defun string< (string1 string2)
  497.   (string<? (string string1) (string string2)))
  498.  
  499. (defun string> (string1 string2)
  500.   (string>? (string string1) (string string2)))
  501.  
  502. (defun string<= (string1 string2)
  503.   (string<=? (string string1) (string string2)))
  504.  
  505. (defun string>= (string1 string2)
  506.   (string>=? (string string1) (string string2)))
  507.  
  508. (defun string/= (string1 string2)
  509.   (not (string=? (string string1) (string string2))))
  510.  
  511. (defun string-lessp (string1 string2)
  512.   (string-ci<? (string string1) (string string2)))
  513.  
  514. (defun string-greaterp (string1 string2)
  515.   (string-ci>? (string string1) (string string2)))
  516.  
  517. (defun string-not-greaterp (string1 string2)
  518.   (string-ci<=? (string string1) (string string2)))
  519.  
  520. (defun string-not-lessp (string1 string2)
  521.   (string-ci>=? (string string1) (string string2)))
  522.  
  523. (defun string-not-equal (string1 string2)
  524.   (not (string-ci=? (string string1) (string string2))))
  525.  
  526. ;; p. 303
  527.  
  528. (defun-clcp %%string-case (string1 char-case)
  529.   (setq string1 (string string1))
  530.   (let* ((length (length string1))
  531.          (string2 (make-string length)))
  532.     (dotimes (i length)
  533.       (setf (char string2 i) (char-case (char string1 i))))
  534.     string2))
  535.  
  536. (defun string-upcase (string)
  537.   (%%string-case string char-upcase))
  538.  
  539. (defun string-downcase (string)
  540.   (%%string-case string char-downcase))
  541.  
  542. ;; We can only get one value back, so bind the rest to NIL and hope they
  543. ;; aren't important.  Later, implement this in terms of CALL/CC if possible.
  544.  
  545. (defmacro multiple-value-bind (variables form &body body)
  546.   (unless (pair? variables)
  547.     (error "The first argument to MULTIPLE-VALUE-BIND, ~S, is not a ~
  548.             list of variables."
  549.            variables))
  550.   (unless (pair? form)
  551.     (error "The second argument to MULTIPLE-VALUE-BIND, ~S, is not a ~
  552.             form to evaluate."
  553.            form))
  554.   `(let ((,(car variables) ,form) .
  555.          ,(map (lambda (variable) `(,variable nil)) (cdr variables)))
  556.      . ,body))
  557.  
  558. ;; Packages (snicker!)
  559.  
  560. (defvar *package*)
  561.  
  562. (defun in-package (package-name)
  563.   (setq *package* package-name))
  564.  
  565. (defun export (symbols &optional package))
  566.  
  567. ;; Modules
  568.  
  569. (defvar *modules* nil)
  570.  
  571. (defun provide (module)
  572.   (unless (member module *modules*)
  573.     (push module *modules*)))
  574.  
  575. (defun require (module &optional pathname)
  576.   (unless (member module *modules*)
  577.     (if pathname
  578.         (load pathname)
  579.         (error "The module ~A has not been provided." module))))
  580.  
  581. (defun lisp-implementation-type ()
  582.   "PC Scheme Common Lisp Compatibility Package")
  583.  
  584. (defun lisp-implementation-version () "1.09")
  585.  
  586. (defun machine-type () "IBM PC compatible")
  587. (defun machine-version () nil)
  588. (defun machine-instance () nil)
  589. (defun software-type () "PC-DOS")
  590. (defun software-version () nil)
  591.  
  592. (defvar *features* '(ieee-floating-point))
  593.  
  594. (defun identity (x) x)
  595.  
  596. (defmacro boundp (thing)
  597.   (unless (and (listp thing)
  598.                (null (cddr thing))
  599.                (eq (car thing) 'quote)
  600.                (symbolp (cadr thing)))
  601.     (error "Unable to translate BOUNDP of ~S." thing))
  602.   `(fluid-bound? ,(cadr thing)))
  603.  
  604. (defmacro eval-when (situation &body body)
  605.   `(begin . ,body))
  606.  
  607. ;; This used to be (defmacro function (x) x) but that made it impossible to
  608. ;; use the FUNCTION as a variable.  Yet another reason this package should be
  609. ;; rewritten as a translator.  FUNCTION is a special form, not a function, so
  610. ;; the following definition isn't quite correct.  However, since FUNCTION is
  611. ;; often used as a variable, this is the best compromise for now.
  612.  
  613. (defun-inline function (x) x)
  614.  
  615. (defun-clcp %%defstruct-initial-slots (initial-slots)
  616.   (let ((result ()))
  617.     (do ((l initial-slots (cddr l)))
  618.         ((null l))
  619.       (when (null (cdr l))
  620.         (error "The keyword ~S does not have a matching value ~
  621.                 in a DEFSTRUCT constructor."
  622.                (car l)))
  623.       (let ((keyword (car l)))
  624.         (when (and (listp keyword)
  625.                    (= (length keyword) 2)
  626.                    (eq (car keyword) 'quote))
  627.           (setq keyword (cadr keyword)))
  628.         (when (symbolp keyword)
  629.           (let ((name (symbol-name keyword)))
  630.             (when (char= (char name 0) #\:)
  631.               (setq keyword (list 'quote (intern (subseq name 1)))))))
  632.         (push keyword result)
  633.         (push (cadr l) result)))
  634.     (nreverse result)))
  635.  
  636. ;; Checking for a PRIMOP-HANDLER is needed here when using LOAD.
  637.  
  638. (defun-clcp %%defstruct-synonym (old-name new-name)
  639.   `(unless (primop-handler ',new-name)
  640.      (define ,new-name ,old-name)
  641.      (copy-primop ',old-name ',new-name)))
  642.  
  643. (defun-clcp %%defstruct (name slots include conc-name print-function)
  644.   (let ((defstruct-slots
  645.           (if include (reverse (get include 'defstruct-slots)) ()))
  646.         (constructor (symbol-append 'make- name))
  647.         (internal-constructor (symbol-append '%%defstruct-make- name)))
  648.     (dolist (slot slots)
  649.       (push (if (symbolp slot) slot (car slot)) defstruct-slots))
  650.     (setq defstruct-slots (nreverse defstruct-slots))
  651.     (let ((result
  652.             `((define-structure
  653.                 ,(if include
  654.                      `(,name (include ,include))
  655.                      name)
  656.                 . ,slots)
  657.               (putprop ',name ',defstruct-slots 'defstruct-slots)
  658.               (define ,internal-constructor ,constructor)
  659.               (defmacro ,constructor (&rest initial-slots)
  660.                 (cons ',internal-constructor
  661.                       (%%defstruct-initial-slots initial-slots)))
  662.               )))
  663.       (when conc-name
  664.         (let ((synonyms ()))
  665.           (dolist (slot defstruct-slots)
  666.             (let ((old-name (symbol-append name "-" slot))
  667.                   (new-name (symbol-append conc-name slot)))
  668.               ;; Checking for a PRIMOP-HANDLER is needed here when using
  669.               ;; COMPILE.
  670.               (unless (primop-handler new-name)
  671.                 (push (%%defstruct-synonym old-name new-name)
  672.                       synonyms))))
  673.           (setq result (append result synonyms))))
  674.       (cons 'begin
  675.             (nconc result
  676.                    (if print-function
  677.                        (list `(putprop ',name
  678.                                        ',print-function
  679.                                        'print-function)))
  680.                    (list `',name))))))
  681.  
  682. (defmacro defstruct (description &rest slots)
  683.   (let ((name description)
  684.         (include nil)
  685.         (conc-name nil)
  686.         (print-function nil))
  687.     (cond ((symbolp description))
  688.           ((not (listp description))
  689.            (error "The first argument to DEFSTRUCT, ~S, was not a ~
  690.                    symbol or list."
  691.                   description))
  692.           (else
  693.             (setq name (pop description))
  694.             (for-each
  695.               (lambda (clause)
  696.                 (let ((key   (first clause))
  697.                       (value (second clause)))
  698.                   (case key
  699.                     (:include
  700.                       (setq include value))
  701.                     (:conc-name
  702.                       (setq conc-name value))
  703.                     (:print-function
  704.                       (setq print-function value))
  705.                     (else
  706.                       (error "The DEFSTRUCT argument ~S is unrecognized."
  707.                              clause)))))
  708.               description)))
  709.     ;; Discard documentation string if one exists.
  710.     (when (stringp (car slots))
  711.       (pop slots))
  712.     (%%defstruct name slots include conc-name print-function)))
  713.  
  714. ;; Returns #F or the structure symbol.
  715.  
  716. (defun-clcp %%structurep (x)
  717.   (and (vectorp x)
  718.        (consp (setq x (svref x 0)))
  719.        (consp (setq x (car x)))
  720.        (eq (car x) '#!STRUCTURE)
  721.        (cdr x)))
  722.  
  723. ;; (defun typep (thing type)
  724. ;;   (and (%%structurep thing)
  725. ;;        (eq (cdar (svref thing 0)) type)))
  726.  
  727. (defun typep (thing type)
  728.   (and (vectorp thing)
  729.        (symbolp type)
  730.        (eq (svref thing 0) (get type '%tag))))
  731.  
  732. ;; Pathnames and directories
  733.  
  734. (define-integrable directory dos-dir)
  735. (define-integrable namestring identity)
  736.  
  737. (defun truename (thing)
  738.   (cond ((output-port? thing)
  739.          "#<Output Port>")
  740.         ((input-port? thing)
  741.          "#<Input Port>")
  742.         (else
  743.           thing)))
  744.  
  745. (defun pathnamep (thing) nil)
  746.  
  747. (defun probe-file (file)
  748.   (let ((dir (dos-dir file)))
  749.     (if dir (car dir))))
  750.  
  751. (newline)
  752. (writeln " Common Lisp Compatibility Package "
  753.          (lisp-implementation-version)
  754.          "   9 September 1990")
  755. (writeln "(C) Copyright 1990 by Carl W. Hoffman")
  756. (writeln "          All Rights Reserved.")
  757.